home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1996 #14
/
Monster Media No. 14 (April 1996) (Monster Media, Inc.).ISO
/
prog_bas
/
savbmp.zip
/
SAVBMP.BAS
< prev
next >
Wrap
BASIC Source File
|
1996-01-02
|
19KB
|
630 lines
Option Explicit
'***************************************************
'
' This app demonstrates a method of saving bitmaps
' at any color depth. Any bitmap may be loaded into
' the picturebox (any color depth: how it displays
' depends on your video driver, however). You can
' then save it as a monochrome, 16-color, 256-color,
' or 16million color bitmap (with the corresponding
' differences in file size!).
' The file is saved as Test.bmp in the app directory.
'
'***************************************************
Type BITMAPFILEHEADER
bfType As Integer
bfsize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Type LOGPALETTE16
PalVersion As Integer
PalNumEntries As Integer
palPalEntry(15) As Long
End Type
Type LOGPALETTE256
PalVersion As Integer
PalNumEntries As Integer
palPalEntry As String * 1024
End Type
Dim FileHead As BITMAPFILEHEADER
Dim InfoHead As BITMAPINFOHEADER
Dim Pal16 As LOGPALETTE16
Dim Pal256 As LOGPALETTE256
Const HEADERLEN = 54
Const BF_TYPE = 19778 ' "BM"
Const PALLEN256 = 1024
Const PALLEN16 = 64
Const PALLEN2 = 8
Const BISIZ = 40
Declare Function GetPixel Lib "GDI" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer) As Long
Declare Function GetNearestPaletteIndex Lib "GDI" (ByVal hPalette As Integer, ByVal crColor As Long) As Integer
Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As Integer
'alias two versions of CreatePalette for 16 or 256 colors
Declare Function CreatePalette16 Lib "GDI" Alias "CreatePalette" (lpLogPalette As LOGPALETTE16) As Integer
Declare Function CreatePalette256 Lib "GDI" Alias "CreatePalette" (lpLogPalette As LOGPALETTE256) As Integer
Function FileExist (Filenam As String) As Integer
' checks whether a filespec exists
Dim Result As Integer
On Error GoTo FileExistErr
Result = GetAttr(Filenam)
FileExist = True
Exit Function
FileExistErr:
FileExist = False
Exit Function
End Function
Function GreyScale (ByVal Colr As Long) As Integer
' Takes a long integer color value and converts it
' to an equivalent grayscale value between 0 and 255
Dim R As Long, G As Long, B As Long
' Break up long color value into red, green, blue
R = Colr Mod 256
Colr = Colr \ 256
G = Colr Mod 256
Colr = Colr \ 256
B = Colr Mod 256
' Find equivalent grayscale value, 0 - 255.
GreyScale = 76 * R / 255 + 150 * G / 255 + 28 * B / 255
End Function
Function InitPal16 () As Integer
Dim hPal As Variant 'I hate Variants, but CreatePalette() returns NULL if unsuccessful
'initialize logical palette
Pal16.PalVersion = &H300
Pal16.PalNumEntries = 16
'16 standard Windows colors
Pal16.palPalEntry(0) = &H0&
Pal16.palPalEntry(1) = &HBF&
Pal16.palPalEntry(2) = &HBF00&
Pal16.palPalEntry(3) = &HBFBF&
Pal16.palPalEntry(4) = &HBF0000
Pal16.palPalEntry(5) = &HBF00BF
Pal16.palPalEntry(6) = &HBFBF00
Pal16.palPalEntry(7) = &H808080
Pal16.palPalEntry(8) = &HC0C0C0
Pal16.palPalEntry(9) = &HFF&
Pal16.palPalEntry(10) = &HFF00&
Pal16.palPalEntry(11) = &HFFFF&
Pal16.palPalEntry(12) = &HFF0000
Pal16.palPalEntry(13) = &HFF00FF
Pal16.palPalEntry(14) = &HFFFF00
Pal16.palPalEntry(15) = &HFFFFFF
'create a logical palette
hPal = CreatePalette16(Pal16)
'red is &HFF& in VB, and goes into the bmp palette as 4 bytes: FF 00 00 00
'because the *low* byte is written *first* to a binary file. This would be
'great, except that the bmp file palette entries are arranged in byte order
'BB GG RR XX; *blue* is the first byte!
'Therefore, rearrange the palette for writing into the bitmap:
Pal16.palPalEntry(0) = &H0&
Pal16.palPalEntry(1) = &HBF0000 'dark blue in VB, but comes out dark red in bmp palette
Pal16.palPalEntry(2) = &HBF00&
Pal16.palPalEntry(3) = &HBFBF00
Pal16.palPalEntry(4) = &HBF&
Pal16.palPalEntry(5) = &HBF00BF
Pal16.palPalEntry(6) = &HBFBF&
Pal16.palPalEntry(7) = &H808080
Pal16.palPalEntry(8) = &HC0C0C0
Pal16.palPalEntry(9) = &HFF0000
Pal16.palPalEntry(10) = &HFF00&
Pal16.palPalEntry(11) = &HFFFF00
Pal16.palPalEntry(12) = &HFF&
Pal16.palPalEntry(13) = &HFF00FF
Pal16.palPalEntry(14) = &HFFFF&
Pal16.palPalEntry(15) = &HFFFFFF
'return the palette handle, or -1 for an error
If IsNull(hPal) Then
InitPal16 = -1
Else
InitPal16 = hPal
End If
End Function
Function InitPal256 (Filenam As String) As Integer
Dim H As Integer, i As Integer
Dim FileHeader As BITMAPFILEHEADER
Dim InfoHeader As BITMAPINFOHEADER
Dim LogPal As LOGPALETTE256
Dim hPal As Variant
Dim tmp As String * 1
Dim chars As String * 4
Pal256.PalVersion = &H300
Pal256.PalNumEntries = 256
' Convert to grayscale:
If Form2!Check2 Then
For i = 1 To 1021 Step 4
' this gives RGB = 0, 0, 0 to RGB = 255, 255, 255
chars = Chr$(i \ 4) & Chr$(i \ 4) & Chr$(i \ 4) & Chr$(0)
Mid$(LogPal.palPalEntry, i, 4) = chars
Mid$(Pal256.palPalEntry, i, 4) = chars
Next i
LogPal.PalVersion = &H300
LogPal.PalNumEntries = 256
hPal = CreatePalette256(LogPal)
GoTo CheckAndExit
'Exit Function
End If
' it's too much typing to hard-code a default palette:
' we'll use the one from rainbow.dib
'FileNam = "c:\vb\rainbow.dib"
'The Filenam parameter above is a hook I never used:
' instead we'll get the file name off Form2
Filenam = Form2!Text1
If Not FileExist(Filenam) Then
MsgBox "Palette file not found!"
GoTo CheckAndExit
'Exit Function
End If
H = FreeFile
Open Filenam For Binary Access Read As #H
Get #H, , FileHeader
Get #H, , InfoHeader
If FileHeader.bfType <> BF_TYPE Then
'not a bitmap
MsgBox "Palette file is Not a bitmap file." & FileHeader.bfType
ElseIf InfoHeader.biBitCount <> 8 Then
'not an 8-bit bitmap
MsgBox "Palette file is Not an 8-bit bitmap."
' ElseIf InfoHeader.biClrsUsed <> 0 and InfoHeader.biClrsUsed <> 256 then
' 'palette may not contain 256 colors
ElseIf FileHeader.bfOffBits <> HEADERLEN + PALLEN256 Then
MsgBox "Palette contains only " & Str$((FileHeader.bfOffBits - HEADERLEN) / 4) & " Colors."
Else
'it's OK, do it
'since we've defined the palette as a 1K string,
'we can read it in one gulp
Get #H, , Pal256.palPalEntry
'Now we've got to rearrange, since the palette just
' read out of the bmp has BGR entries, but we need
' RGB for the logical palette
For i = 1 To 1021 Step 4
Mid$(LogPal.palPalEntry, i, 1) = Mid$(Pal256.palPalEntry, i + 2, 1)
Mid$(LogPal.palPalEntry, i + 1, 1) = Mid$(Pal256.palPalEntry, i + 1, 1)
Mid$(LogPal.palPalEntry, i + 2, 1) = Mid$(Pal256.palPalEntry, i, 1)
Next i
LogPal.PalVersion = &H300
LogPal.PalNumEntries = 256
' create the logical palette and retrieve its handle
hPal = CreatePalette256(LogPal)
End If
Close #H
CheckAndExit:
If IsNull(hPal) Or IsEmpty(hPal) Then
InitPal256 = -1
Else
InitPal256 = hPal
End If
End Function
Sub Output16Bmp (Filenam As String, Pict As Control)
'This routine reads a picturebox pixel by pixel and writes a
'16-color bitmap to disk using the "nearest" standard color
Dim PixelsWide As Integer, PixelsHi As Integer
Dim OutH As Integer
Dim i As Integer, j As Integer, k As Integer
Dim Line16$
Dim Colr&
Dim hPal As Integer
Dim PicHDC As Integer
Dim PalNum As Integer
' Set up the standard 16-color palette
hPal = InitPal16()
If hPal = -1 Then
MsgBox ("Problem creating palette!")
Exit Sub
End If
Screen.MousePointer = 11
' The output bitmap is the same size as the picturebox:
' Picture1 has AutoSize = True and ScaleMode = 3 (pixel)
PixelsWide = Pict.ScaleWidth
PixelsHi = Pict.ScaleHeight
' Open disk file for storing 16-color bmp:
OutH = FreeFile
Open Filenam For Binary Access Write As #OutH
' set header data
InfoHead.biSize = BISIZ
InfoHead.biWidth = PixelsWide
InfoHead.biHeight = PixelsHi
InfoHead.biPlanes = 1
InfoHead.biBitCount = 4
InfoHead.biSizeImage = CLng(PixelsWide) * PixelsHi / 2
InfoHead.biClrImportant = 0
FileHead.bfType = BF_TYPE
FileHead.bfOffBits = HEADERLEN + PALLEN16
FileHead.bfsize = FileHead.bfOffBits + WidthBytes(PixelsWide, InfoHead.biBitCount) * CLng(PixelsHi)
Put #OutH, , FileHead
Put #OutH, , InfoHead
' now write the 16-color palette to the file
For i = 0 To 15
Put #OutH, , Pal16.palPalEntry(i)
Next i
' allocate string buffer to hold one line of 16-color bmp
Line16$ = Space(WidthBytes(PixelsWide, InfoHead.biBitCount))
' get the picturebox hDC for GetPixel()
PicHDC = Pict.hDC
' loop through all pixels in the image
For i = PixelsHi - 1 To 0 Step -1
'change picture to 16-color format:
'one byte of 16-color data = 2 pixels
For j = 0 To PixelsWide - 1 Step 2
'build up one byte (for two pixels of image)
'in the low byte of an integer:
PalNum = 0
For k = 0 To 1
'get color of this pixel from picturebox
'GetPixel is a little faster than Point
''Colr& = Pict.Point(j + k, i)
Colr& = GetPixel(PicHDC, j + k, i)
'find nearest color in std windows palette
'and load into appropriate bits of integer PalNum.
'Exponentiation is slow, so I use the If/Else instead
''PalNum = PalNum Or 16 ^ (1 - k) * GetNearestPaletteIndex(hPal, Colr&)
If k = 0 Then 'upper nibble
PalNum = PalNum Or 16 * GetNearestPaletteIndex(hPal, Colr&)
Else 'lower nibble
PalNum = PalNum Or GetNearestPaletteIndex(hPal, Colr&)
End If
Next k
' add PalNum byte to character buffer
Mid$(Line16$, j / 2 + 1, 1) = Chr$(PalNum)
Next j
'write out a line of the bmp
Put #OutH, , Line16$
DoEvents
Next i
'All done: close the disk file
Close #OutH
'release the palette
i = DeleteObject(hPal)
Screen.MousePointer = 0
If i = 0 Then MsgBox "Couldn't release palette!"
End Sub
Sub Output24BitBmp (Filenam As String, Pict As Control)
'This routine reads a picturebox pixel by pixel and writes a
'16M-color bitmap to disk
Dim PixelsWide As Integer, PixelsHi As Integer
Dim OutH As Integer
Dim i As Integer, j As Integer
Dim Line16M$
Dim Colr&
Dim PicHDC As Integer
Dim Red%, Green%, Blue%
Screen.MousePointer = 11
'******************************
'Dim start
'start = Timer
'******************************
' The output bitmap is the same size as the picturebox:
' Picture1 has AutoSize = True and ScaleMode = 3 (pixel)
PixelsWide = Pict.ScaleWidth
PixelsHi = Pict.ScaleHeight
' Open disk file for storing 16M-color bmp:
OutH = FreeFile
Open Filenam For Binary Access Write As #OutH
' set header data
InfoHead.biSize = BISIZ
InfoHead.biWidth = PixelsWide
InfoHead.biHeight = PixelsHi
InfoHead.biPlanes = 1
InfoHead.biBitCount = 24
InfoHead.biSizeImage = CLng(PixelsWide) * PixelsHi * 3
InfoHead.biClrImportant = 0
FileHead.bfType = BF_TYPE
FileHead.bfOffBits = HEADERLEN
FileHead.bfsize = FileHead.bfOffBits + WidthBytes(PixelsWide, InfoHead.biBitCount) * CLng(PixelsHi)
Put #OutH, , FileHead
Put #OutH, , InfoHead
' buffer to hold one line of 16M-color bmp
Line16M = Space(WidthBytes(PixelsWide, InfoHead.biBitCount))
PicHDC = Pict.hDC
' loop through all pixels in the image
For i = PixelsHi - 1 To 0 Step -1
'change picture to 16M-color format:
'three bytes of 16M-color data = 1 pixel
For j = 0 To PixelsWide - 1 Step 1
'build up 3 bytes for one pixel of image
'get color of this pixel from picturebox
'GetPixel is a little faster than Point
'Colr& = Pict.Point(j, i)
Colr& = GetPixel(PicHDC, j, i)
'Break up long color value into RGB
Red% = Colr& Mod 256
Colr& = Colr& \ 256
Green% = Colr& Mod 256
Colr& = Colr& \ 256
Blue% = Colr& Mod 256
Mid$(Line16M$, j * 3 + 1, 1) = Chr$(Blue%)
Mid$(Line16M$, j * 3 + 2, 1) = Chr$(Green%)
Mid$(Line16M$, j * 3 + 3, 1) = Chr$(Red%)
Next j
'write out a line of the bmp
Put #OutH, , Line16M$
Next i
'All done: close the disk file
Close #OutH
Screen.MousePointer = 0
'*****************************
'Debug.Print Timer - start
'*****************************
End Sub
Sub Output256Bmp (Filenam As String, Pict As Control)
'This routine reads a picturebox pixel by pixel and writes a
'256-color bitmap to disk using the nearest available color
Dim PixelsWide As Integer, PixelsHi As Integer
Dim OutH As Integer
Dim i As Integer, j As Integer
Dim Line256$
Dim Colr&
Dim hPal As Integer
Dim PicHDC As Integer
Dim PalNum As Integer
'******************************
'Dim start
'start = Timer
'******************************
' Set up the 256-color palette
hPal = InitPal256("dummy")
If hPal = -1 Then Exit Sub 'didn't work
Screen.MousePointer = 11
' The output bitmap is the same size as the picturebox:
' Picture1 has AutoSize = True and ScaleMode = 3 (pixel)
PixelsWide = Pict.ScaleWidth
PixelsHi = Pict.ScaleHeight
' Open disk file for storing 256-color bmp:
OutH = FreeFile
Open Filenam For Binary Access Write As #OutH
' set header data
InfoHead.biSize = BISIZ
InfoHead.biWidth = PixelsWide
InfoHead.biHeight = PixelsHi
InfoHead.biPlanes = 1
InfoHead.biBitCount = 8
InfoHead.biSizeImage = CLng(PixelsWide) * PixelsHi
InfoHead.biClrImportant = 0
FileHead.bfType = BF_TYPE
FileHead.bfOffBits = HEADERLEN + PALLEN256
FileHead.bfsize = FileHead.bfOffBits + WidthBytes(PixelsWide, InfoHead.biBitCount) * CLng(PixelsHi)
Put #OutH, , FileHead
Put #OutH, , InfoHead
' now write the 256-color palette to the file
Put #OutH, , Pal256.palPalEntry
' buffer to hold one line of 16-color bmp
Line256$ = Space(WidthBytes(PixelsWide, InfoHead.biBitCount))
PicHDC = Pict.hDC
' loop through all pixels in the image
For i = PixelsHi - 1 To 0 Step -1
'change picture to 256-color format:
'one byte of 256-color data = 1 pixel
For j = 0 To PixelsWide - 1 Step 1
'build up one byte for one pixel of image
'in the low byte of an integer:
PalNum = 0
'get color of this pixel from picturebox
'GetPixel is a little faster than Point
'Colr& = Pict.Point(j, i)
Colr& = GetPixel(PicHDC, j, i)
'find nearest color in palette
PalNum = GetNearestPaletteIndex(hPal, Colr&)
' add PalNum byte to PalNum line buffer
Mid$(Line256$, j + 1, 1) = Chr$(PalNum)
Next j
'write out a line of the bmp
Put #OutH, , Line256$
DoEvents
Next i
'All done: close the disk file
Close #OutH
'release the palette
i = DeleteObject(hPal)
Screen.MousePointer = 0
If i = 0 Then MsgBox "Couldn't release palette!"
'*****************************
'Debug.Print Timer - start
'*****************************
End Sub
Sub OutputMonoBmp (Filenam As String, Pict As Control)
'This routine reads a picturebox pixel by pixel and writes
' a monochrome bitmap to disk.
Dim AllToBlack As Integer, Threshold As Integer
Dim PixelsWide As Integer, PixelsHi As Integer
Dim OutH As Integer
Dim i As Integer, j As Integer, k As Integer
Dim LineMono$
Dim Colr&
Dim PicHDC As Integer
Dim mono As Integer
Dim BLACK As Long, WHITE As Long
BLACK = &H0&
WHITE = &HFFFFFF
Screen.MousePointer = 11
'******************************
'Dim start
'start = Timer
'******************************
AllToBlack = Form2!Option1(0)
Threshold = Val(Form2!Label1)
' The output bitmap is the same size as the picturebox:
' Picture1 has AutoSize = True and ScaleMode = 3 (pixel)
PixelsWide = Pict.ScaleWidth
PixelsHi = Pict.ScaleHeight
' Open disk file for storing monochrome bmp:
OutH = FreeFile
Open Filenam For Binary Access Write As #OutH
' header info
InfoHead.biSize = BISIZ
InfoHead.biWidth = PixelsWide
InfoHead.biHeight = PixelsHi
InfoHead.biPlanes = 1
InfoHead.biBitCount = 1
InfoHead.biSizeImage = CLng(PixelsWide) * PixelsHi / 8
InfoHead.biClrImportant = 0
FileHead.bfType = BF_TYPE
FileHead.bfOffBits = HEADERLEN + PALLEN2
FileHead.bfsize = FileHead.bfOffBits + WidthBytes(PixelsWide, InfoHead.biBitCount) * CLng(PixelsHi)
Put #OutH, , FileHead
Put #OutH, , InfoHead
' palette (black and white)
If Form2!Check1 Then
' negative image
Put #OutH, , WHITE
Put #OutH, , BLACK
Else
Put #OutH, , BLACK
Put #OutH, , WHITE
End If
' buffer to hold one line of mono bmp
LineMono$ = Space(WidthBytes(PixelsWide, InfoHead.biBitCount))
PicHDC = Pict.hDC
' loop through all pixels in the image
For i = PixelsHi - 1 To 0 Step -1
'change picture to mono format:
''one byte of mono data = 8 pixels
For j = 0 To PixelsWide - 1 Step 8
' build up mono byte (for eight pixels of image)
' in the low byte of an integer:
mono = 0
For k = 0 To 7
'get color of this pixel from picturebox
'GetPixel is a little faster than Point
'Colr& = Pict.Point(j + k, i)
Colr& = GetPixel(PicHDC, j + k, i)
If AllToBlack Then
' white is the background color: anything else is black.
'if it's white, set that bit. Otherwise, just go on to next
'Note: exponentiation is *slow*: select case would be faster
If Colr& = WHITE Then mono = mono Or 2 ^ (7 - k)
Else
' any color lighter than the threshold goes white:
If GreyScale(Colr&) >= Threshold Then mono = mono Or 2 ^ (7 - k)
End If
Next k
' add mono byte to mono line buffer
Mid$(LineMono$, j / 8 + 1, 1) = Chr$(mono)
Next j
'write out a line of mono bmp
Put #OutH, , LineMono$
DoEvents
Next i
'All done: close the disk file
Close #OutH
Screen.MousePointer = 0
'*****************************
'Debug.Print Timer - start
'*****************************
End Sub
Function WidthBytes (Wide As Integer, BitCount As Integer) As Integer
' all bmps must have a multiple of 32 bits (a long integer)
' in each row even if not all the bits are used
Dim tmp!
Dim i%
tmp! = Wide * BitCount / 32
i% = Int(tmp!)
If i% <> tmp! Then i% = i% + 1
WidthBytes = i% * 4
End Function
Function WidthBytes2 (Wide As Integer, BitCount As Integer) As Integer
' this is a neat algorithm I stole from VB4 How-To.
' I'm not sure I get it, but it *does* work!
WidthBytes2 = ((CLng(BitCount) * CLng(Wide) + 31&) And &HFFE0) \ 8
End Function